word : header
word word ?find compile,
word header ?find compile,
word -1 ?find compile,
word state ?find compile,
word ! ?find compile,
word semis ?find compile,

word ; header
word lit ?find compile,
word semis ?find ,
word compile, ?find compile,
word 0 ?find compile,
word state ?find compile,
word ! ?find compile,
word semis ?find compile,
word ; ?find xt-afa-offset + dup @ immediate-bit or swap !

: xt->link xt-lfa-offset + ;
: xt-link xt->link @ ;
: xt->name xt-nfa-offset + ;
: xt-name xt->name @ ;
: xt->attribute xt-afa-offset + ;
: xt-attribute xt->attribute @ ;

: primitive? xt-attribute primitive-bit and ;
: immediate? xt-attribute immediate-bit and ;

: latest
  image-latest @ ;
: attribute-set
  swap xt->attribute dup @ or ! ;

: immediate
  latest immediate-bit attribute-set ; immediate

: compile? state @ ;
: dummy, here 0 , ;
: [ immediate state off ;
: ] state on ;

: postpone immediate
  word ?find compile, ;

: '
  word ?find ;
: compile
  ' compile, ;
: [compile] immediate
  compile ;

: lit,
  [compile] lit [compile] lit , ;
: literal immediate
  [compile] lit [compile] lit , , ;
: ['] immediate
  ' postpone literal ;
: (compile) immediate
  postpone ['] ['] compile, compile, ;

: if immediate
  (compile) 0branch
  dummy, ;
: unless immediate
  (compile) 1branch
  dummy, ;
: else immediate
  (compile) branch
  dummy, swap
  here swap ! ;
: then immediate
  here swap ! ;

: begin immediate
  here ;
: until immediate
  (compile) 0branch , ;

: char
  skipws key ;
: [char] immediate
  char postpone literal ;
: [emit] immediate
  postpone [char] ['] emit compile, ;

: ( immediate
  1 begin
    key dup [char] ( = if
      drop 1+
    else
      [char] ) = if 1- then
    then
  dup 0= until
  drop ;

: -- immediate ( - )
  ( 行末までのコメント )
  begin key 'cr' = until ;

-- Util

: bye ( - ) 0 exit ;

: recurse immediate ( - )
  latest compile, ;

: see ( s:name / - )
  ' 40 cdump ;

: { immediate ( - xt )
  (compile) litblock
  dummy,
  ] ;
: } immediate ( - )
  (compile) return
  here swap !
  ] ;

-- Loop control

: again immediate ( - )
  (compile) branch
  , ( [begin] compile ) ;

( [begin] test -- 0branch [end]
body -- branch [begin] [end] )

: while immediate ( - [end] )
  (compile) 0branch
  dummy, ( save [end] ) ;
: repeat immediate ( [begin] [end] - )
  (compile) branch swap , ( [begin] compile )
  here swap ! ( [end] compile ) ;

: do immediate ( - )
  (compile) (do)
  postpone begin ;
: loop immediate ( - )
  (compile) (loop) , ;

-- Return stack

: clear-rstack ( - )
  rp0 @ rp! ;

-- Stack

: sp0@ ( - a )
  sp0 @ ;

: depth ( - x )
  sp0 @ sp@ - cell / 1- ;

: clear-stack ( - )
  sp0 @ sp! ;

: .s ( - )
  [emit] < depth .d [emit] > space
  sp@
  begin
    dup sp0 @ < while
      dup @ .
      cell+
  repeat
  drop ;

: (.s) immediate ( - )
  (compile) .s ;

-- Define

: create ( s:name )
  word header [compile] lit [compile] dovar , ;
: variable ( s:name )
  create cell allot ;
: constant ( s:name / x - )
  word header [ lit, ' docon compile, ] , , ;
: value ( s:name / x - )
  word header [ lit, ' docon compile, ] , , ;
: to ( s:name / x - )
  ' cell+ ! ;
: alias ( s:new-name )
  word intern
  current @ vocabulary-set ;

' 0 alias false
' -1 alias true
' 0= alias not
' @ alias first
' ! alias first!
' first alias car
' first! alias car!
' second alias cdr
' second! alias cdr!

-- String

: align ( - )
  here aligned dp ! ;

: s" immediate ( s: ..." - ca )
  ['] litblock compile,
  dummy,
  begin
    key dup '"' <>
  while
    c,
  repeat drop ( drop " )
  'null' c, align
  here swap ! ;

: ." immediate ( -- )
  postpone s" (compile) type ;

-- IO

: *flush ( - )
  output @ flush ;

-- User Stack

: stack ( - a )
  1 @cell ;

: stack-drop ( stack - )
  pop drop ;

: stack-top ( stack - a )
  first ;

: stack-tos ( stack - x )
  first first ;

: stack-null? ( stack - f )
  ?dup if @ not else true then ;

: stack-size ( stack - n )
  0 >r ( counter )
  stack-top ( list )
  begin ?dup while cdr 1 r+ repeat
  r> ;

-- Exception

: init-mpool ( - )
  1024 mpool-new engine-mpool ! ;

: init-callback ( - )
  stack callback ! ;

: exception-message ( n - ca )
  exception-messages i@ ;

: restart ( - )
  clear-stack clear-rstack
  callback-flag off
  begin interpreter again ;

: callback-default ( n - )
  ." error[" dup .d ." ]: " dup exception-message type cr *flush
  latest-ip @ 2 cells - 20 cdump
  restart ;

: init-callback-word ( - )
  ['] callback-default image-callback ! ;

: init ( - )
  init-mpool
  init-callback
  init-callback-word ;

: callback? ( - f )
  callback-flag @ ;

: callback-stack ( - stack )
  callback @ ;

: catch ( xt - 0 | n )
  ( xtを実行しコールバックを受け取る。
    もし、xtで例外が発生せず通常通りxtが戻ってくれば、
    0を返す、それ以外は例外コードを返す。 )
  rp callback-stack push
  execute
  callback? unless 0 callback-stack stack-drop then ;

: throw ( x - x )
  ( 例外を発生させる、xは例外コード。 )
  callback-flag on ( 例外発生を知らせるフラグを立てる )
  callback-stack stack-null? if
    ( callback-stackが空の場合, デフォルト関数呼び出す )
    ." callback error" cr
    restart
  else
    ( callback-stackからxtを取り出しリターンスタックを復元する )
    callback-stack pop rp!
  then ;

init

-- IO

: "core.fi" s" core.fi" ;

: image-size ( -- n )
  here image - ;

: image-offset-reset ( -- )
  image image-offset ! ;

: image.save ( "name" -- )
  image-offset-reset
  -- イメージを保存する
  w/o file-open dup output !
  -- ファイルに書き込む
  here image do
    i c@ emit loop
  -- インプットを戻す
  <-port} std-output-port output ! ;

"core.fi" image.save

image-size allocate value image2

image2 image-size
"core.fi" r/o file-open
read
->port}


: load-image ( "name" -- )
  r/o file-open
  dup input !
  -- ファイルを読み込む
  
: "jjjj" s" jjjj" ;
"jjjj" w/o file-open
dup value jjjj-port output !
"jjjj" type cr
"jjjj" type cr
jjjj-port <-port}
-- もとに戻す
std-output-port output !

-- Dictionary

-- : (save) ( ca -- )
--   ;

-- : save ( s: name -- )
--   word (save) ;

-- Vocabulary

: vocabulary-name ( vocab - ca ) @ ;
: vocabulary-context ( vocab - vocab2 ) cell+ @ ;
: vocabulary-entrys ( vocab - a ) 2 cells + @ ;

: context ( - context )
  current @ vocabulary-context ;

: >context ( vocab - )
  context push ;

: vocabulary ( s: name - )
  word (vocabulary) ;

: Core vocabulary-core ;

: words ( - )
  0 >r latest begin
    xt-link ?dup while
      dup xt-name dup type space *flush
      strlen r> + dup 40 > if ( count )
        drop 0 cr
      then
      >r
  repeat drop cr
  output @ flush r> ;

: word-count ( - n )
  0 latest begin
    xt-link ?dup while
      swap 1+ swap
  repeat ;

-- Case

( case -- push 0
    test1 of ... endof => test1 over = if drop ... else
    test2 of ... endof => test2 over = if drop ... else
    test3 of ... endof => test3 over = if drop ... else
  endcase )

: case immediate ( - 0 )
  0 ;

: of immediate ( - )
  (compile) over
  (compile) =
  postpone if
  (compile) drop ;

: endof immediate ( - )
  postpone else ;

: endcase immediate ( - )
  (compile) drop
  begin ?dup while postpone then repeat ;

-- See

: attribute. ( xt - )
  dup primitive? if ." primitive " then
  dup immediate? if ." immediate " then ;

-- : (see) ( xt - )
--   ( display name )
--   ." : " dup xt-name type
--   ( display attribute )
--   space dup attribute. cr
--   ( display code )
--   begin
--     ...
--   while
--     case
--       ['] lit of
--         cell+ @ . endof
--       ['] litblock of
--         ." [ " ." ] "
--   repeat ;

-- IO --

: buffer-start ( buffer - ca ) first ;
: buffer-current ( buffer - ca ) second ;
: buffer-end ( buffer - ca ) third ;

: input-type ( input - type ) first ;
: input-buffer ( input - buffer ) second ;

: input-buffer-end? ( input - f )
  input-buffer
  dup buffer-current over buffer-end >= ;

-- Compile --

-- : dotype? ( x -- f )
  
-- : compile, ( xt -- )
--   dup primitive? if
--     @ ,
--   else
--     ['] call ,
--   then ;
-- : compile ( xt -- )
--   dup immediate? compile? or if
--     execute
--   else
    
--   then ;
-- : compile.string
--   dup number? if
--     number state if
--       ['] lit , ,
--     then
--   else
--     drop UNDEFINED_WORD throw
--   then ;

: compile ( xt -- )
  dup immediate? compile? not or cond
    dup primitive? of execute endof
    dup primitive? of execute endof
    end
  else
    compile,
  then ;

-- Interpreter --

: tib-clear ( - )
  cib tib ! ;

: interpreter ( - )
  ." > " *flush
  word find ?dup if
    compile
  else
    case
      dup number? of
        compile? if postpone literal then
        endof
      ( default )
    endcase
  then
  ( end )
  -- ?stack
  *flush
  input @ input-buffer-end? if tib-clear then ;
